home *** CD-ROM | disk | FTP | other *** search
/ Atari Forever 4 / Atari Forever 4.zip / Atari Forever 4.iso / PD_THEMA / BIORHYTM / BIORHYTH.PD / BIORHYTH.PAS next >
Pascal/Delphi Source File  |  1998-03-14  |  30KB  |  849 lines
  1. program biorhythmus; {(c) 1987/88 mkb }
  2.  
  3.  
  4. { ----------------- Systemunabhängige Variablen/Konstanten ------------------ }
  5.  
  6. type  byte = 0..255;                { nur nötig, wenn nicht implementiert }
  7.       dat  = record
  8.                jahr   : integer;
  9.                monat  : byte;
  10.                tag    : byte;
  11.                schalt : boolean;
  12.                system : byte;
  13.              end;
  14.       sht  = string;
  15.       
  16. const stichjahr     = 1582;
  17.       stichmonat    = 10;
  18.       stichtag_jul  = 4;
  19.       stichtag_greg = 15;
  20.       koerper       = 0.27318197;   { hier evtl. genauere Werte (je nach    }
  21.       seele         = 0.224399475;  { System) einsetzen, diese zieml. genau }
  22.       geist         = 0.190399555;  {                                       }
  23.       null          = 55;
  24.       imp_version   = '4.mG';       { Version 4.09 auf Mot. 68000 in Deutsch }
  25.       
  26. var   monatsl       : array [1..12]            of byte;
  27.       verg          : array [1..12]            of integer;
  28.       wert2         : array [0..7]             of integer;
  29.       monatsn       : array [1..12]            of string[10];
  30.       wert          : array [1..3,1..12,1..31] of byte;
  31.       druckstr      : array [1..7]             of string[8];
  32.       geb_datum     : dat;
  33.       akt_datum     : dat;
  34.       testdat       : dat;
  35.       print         : string [80];
  36.       print1        : string [8];
  37.       print2        : string [8];
  38.       print3        : string [8];
  39.       beenden       : boolean;
  40.       testdiff      : real;
  41.       i,u,w         : integer; 
  42.       
  43. { ------------- Systemabhängige Variablen : hier f. ATARI ST ---------------- }
  44.  
  45.       handle_gem   : integer;
  46.       work_gem     : array [0..56]             of integer;
  47.       
  48.  
  49. { ---------------- Systemabhängiger Teil : hier f. ATARI ST ----------------- }
  50.  
  51. procedure curs_on;
  52.   var i : integer;
  53.   begin
  54.     i:=cursconf(1,0);
  55.     i:=cursconf(4,20);
  56.     i:=kbrate(14,2);
  57.   end;
  58.  
  59. procedure curs_off;
  60.   var i : integer;
  61.   begin
  62.     i:=cursconf(0,0);
  63.     i:=kbrate(8,3);
  64.   end;
  65.  
  66. procedure hireson;
  67.   begin
  68.     curs_off;                                     { Mindestgrafikauflösung : }
  69.     for i:=0 to 9 do work_gem[i]:=1;              {                          }
  70.     work_gem[10]:=2;                              {                          }
  71.     v_opnvwk(work_gem,handle_gem,work_gem);       {                          }
  72.     work_gem[0]:=vswr_mode(handle_gem,3);         {  640 * 200 Punkte HIRES  }
  73.     work_gem[0]:=vsl_type(handle_gem,1);    
  74.     work_gem[0]:=vsl_width(handle_gem,1);         { Hier eine bel. HIRES-    }
  75.     vsl_ends(handle_gem,0,0);                     { Grafikauflösung einschal-}
  76.     hidemouse;                                    { ten.                     }
  77.   end;
  78.  
  79. procedure hiresoff;
  80.   begin
  81.     v_clsvwk(handle_gem);
  82.     curs_on;
  83.   end;
  84.  
  85. procedure clrhires;
  86.   begin
  87.     clrscr;
  88.   end;
  89.  
  90. procedure plot(x,y : integer);
  91.   begin
  92.     work_gem[0]:=x;                         { Umrechnungen :                 }
  93.     work_gem[1]:=400-2*y;                   {                                }
  94.     work_gem[2]:=x;                         { X_koor = (X_Aufl/640)*x        }
  95.     work_gem[3]:=400-2*y;                   { Y_koor = Y_Aufl-(Y_Aufl/200)*y }
  96.     v_pline(handle_gem,2,work_gem);         { [Nullpunkt : unten links !]    }
  97.   end;                                      { X_Aufl : Die eigene x-Aufl.    }
  98.                                             { Y_Aufl : Die eigene y-AUfl.    }
  99. procedure line(x1,y1,x2,y2 : integer);
  100. begin
  101.   work_gem[0]:=x1;
  102.   work_gem[1]:=400-2*y1;
  103.   work_gem[2]:=x2;
  104.   work_gem[3]:=400-2*y2;
  105.   v_pline(handle_gem,2,work_gem);
  106. end;
  107.  
  108. procedure printat(x,y : integer;print : sht);
  109. begin
  110.   gotoxy(x,y-1);write(print);                       { Umrechnungen :         }
  111. end;                                                {                        }
  112.                                                     { Bildschirm hat 2000    }
  113. procedure writesmall(x,y : integer;print : sht);    { Zeichen : 80*25        }
  114. var i:integer;                                      { Nullpunkt [0;0] :      }
  115. begin                                               {  links oben            }
  116.   for i:=0 to length(print)-1 do                    { Werteber. : x) 0..79   }
  117.     put_char(print[i+1],x*8+i*8,(y*16)-4,0);        {             y) 0..24   }
  118. end;                                                {    [von y evtl. 1 ab-  }
  119.                                                     {                ziehen] }
  120. procedure hardcopy;                                 { Zeichenmatrix : 8*8    }
  121. begin
  122.   scrdmp;                                           { eigene Routine oder    }
  123. end;                                                { Systemroutine          }
  124.  
  125. procedure druckeranpassung;
  126. begin
  127.   
  128.   druckstr[1]:='..';      ; { Für jedes Steuerbefehlzeichen ein Punkt }
  129.   druckstr[1][1]:=chr(13) ; { chr(0) zählt nicht mitrechnen !         }
  130.   druckstr[1][2]:=chr(10) ;
  131.   druckstr[1][3]:=chr(00) ; { Zeilenvorschub }
  132.   
  133.   druckstr[2]:='.';
  134.   druckstr[2][1]:=chr(12) ;
  135.   druckstr[2][2]:=chr(00) ; { Seitenauswurf }
  136.   druckstr[3]:='..';
  137.   
  138.   druckstr[3][1]:=chr(27) ;
  139.   druckstr[3][2]:=chr(69) ;
  140.   druckstr[3][3]:=chr(00) ; { Fettdruck Anf./evtl. dopp. Anschlag }
  141.   
  142.   druckstr[4]:='..';
  143.   druckstr[4][1]:=chr(27) ;
  144.   druckstr[4][2]:=chr(70) ;
  145.   druckstr[4][3]:=chr(00) ; { Fettdruck Ende/evtl. dopp. Anschlag }
  146.   
  147.   druckstr[5]:='...';
  148.   druckstr[5][1]:=chr(27) ;
  149.   druckstr[5][2]:=chr(87) ;
  150.   druckstr[5][3]:=chr(49) ;
  151.   druckstr[5][4]:=chr(00) ; { Hervorhebung Anfang - hier dopp. B.}
  152.   
  153.   druckstr[6]:='...';
  154.   druckstr[6][1]:=chr(27) ;
  155.   druckstr[6][2]:=chr(87) ;
  156.   druckstr[6][3]:=chr(48) ;
  157.   druckstr[6][4]:=chr(00) ; { Hervorhebung Ende   - evtl. Kursiv }
  158.   
  159.   { statt Fettdruck        : doppelter Anschlag/NLQ                       }
  160.   { statt doppelter Breite : Invertdruck - chr(18) bei mps80x-kompatiblen }
  161.  
  162. end;
  163.  
  164.  
  165. { -------------------- ab hier computerunabhängiger Teil ---------------------}
  166.  
  167. procedure initarrays;
  168. begin
  169.   wert2[1]:=1 ;wert2[2]:=2 ;wert2[3]:=4  ;wert2[4]:=8;wert2[5]:=16;
  170.   wert2[6]:=32;wert2[7]:=64;wert2[8]:=128;
  171.   monatsl[1]:=31;monatsl[2]:=29 ;monatsl[3]:=31 ;monatsl[4]:=30;
  172.   monatsl[5]:=31;monatsl[6]:=30 ;monatsl[7]:=31 ;monatsl[8]:=31;
  173.   monatsl[9]:=30;monatsl[10]:=31;monatsl[11]:=30;monatsl[12]:=31;
  174.   verg[1]:=0   ;verg[2]:=31  ;verg[3]:=59 ;verg[4]:=90 ;verg[5]:=120 ;
  175.   verg[6]:=151 ;verg[7]:=182 ;verg[8]:=213;verg[9]:=243;verg[10]:=273;
  176.   verg[11]:=304;verg[12]:=334;
  177.   monatsn[1]:='Januar'  ;monatsn[2]:='Februar'  ;monatsn[3]:='März';
  178.   monatsn[4]:='April'   ;monatsn[5]:='Mai'      ;monatsn[6]:='Juni';
  179.   monatsn[7]:='Juli'    ;monatsn[8]:='August'   ;monatsn[9]:='September';
  180.   monatsn[10]:='Oktober';monatsn[11]:='November';monatsn[12]:='Dezember';
  181. end;
  182.   
  183. function julianisch (datum : dat) : real;
  184.     begin
  185.       julianisch:=(datum.jahr-1)*365+verg[datum.Monat]+((datum.jahr-1) div 4)+
  186.                   datum.tag;
  187.     end;
  188.  
  189. function gregorianisch (datum : dat) : real;
  190.     begin
  191.       gregorianisch:=(datum.jahr-1)*365+verg[datum.monat]+((datum.jahr-1) 
  192.                      div 4)-((datum.jahr-1) div 100) + ((datum.jahr-1) div 400)
  193.                      + datum.tag;
  194.     end;
  195.  
  196. procedure zeitdifferenz (var diff : real;geb_datum : dat;akt_datum : dat);
  197.   var diff_1 : real;
  198.       diff_2 : real;
  199.       dummy  : dat;
  200.   
  201.   procedure korrektur (datum : dat;var diff : real);
  202.     begin
  203.       if (datum.schalt=true) and (datum.monat>=3) then diff:=diff+1;
  204.     end;
  205.     
  206.   begin
  207.     if (geb_datum.system)=(akt_datum.system) then begin
  208.       if (geb_datum.system)=1 then begin
  209.         diff_1:=julianisch(geb_datum);
  210.         diff_2:=julianisch(akt_datum);
  211.       end;
  212.       if (geb_datum.system)=2 then begin
  213.         diff_1:=gregorianisch(geb_datum);
  214.         diff_2:=gregorianisch(akt_datum);
  215.       end;
  216.       korrektur(geb_datum,diff_1);
  217.       korrektur(akt_datum,diff_2);
  218.       diff:=diff_2-diff_1;
  219.     end
  220.     else begin
  221.       dummy.jahr:=stichjahr;
  222.       dummy.monat:=stichmonat;
  223.       dummy.tag:=stichtag_jul;
  224.       diff_1:=julianisch(geb_datum);
  225.       diff_2:=julianisch(dummy);
  226.       korrektur(geb_datum,diff_1);
  227.       diff:=diff_2-diff_1;
  228.       dummy.tag:=stichtag_greg;
  229.       diff_1:=gregorianisch(dummy);
  230.       diff_2:=gregorianisch(akt_datum);
  231.       korrektur(akt_datum,diff_2);
  232.       diff:=diff+(diff_2-diff_1)+1;
  233.     end;
  234.   end;
  235.   
  236. function wochentag (datum : dat) : integer ;
  237.   var j,c,t,m : real;
  238.   begin
  239.     c:=datum.jahr div 100;
  240.     j:=datum.jahr-c*100;
  241.     if datum.monat<3 then begin
  242.       datum.monat:=datum.monat+12;
  243.       j:=j-1;
  244.       if j<0 then begin
  245.         j:=99;
  246.         c:=c-1;
  247.       end;
  248.     end;
  249.     m:=datum.monat;
  250.     t:=datum.tag;
  251.     case datum.system of
  252.       1 : t:=t+int((m+1)*26/10)+j+int(j/4)+5-c;
  253.       2 : t:=t+int((m+1)*26/10)+j+int(j/4)+int(c/4)-2*c;
  254.     end;
  255.     t:=t-7*int(t/7);
  256.     repeat
  257.       if t>6 then t:=t-7;
  258.     until t<=7;
  259.     wochentag:=round(t);
  260.   end;
  261.  
  262. procedure drucke (x,y : integer;datum : dat); 
  263.   var print1 : string[5];
  264.       print2 : string[5];
  265.       print3 : string[5];
  266.       print  : string[20];
  267.       i      : integer;
  268.   begin
  269.     str(datum.tag,print1);
  270.     str(datum.monat,print2);
  271.     str(datum.jahr,print3);
  272.     print:=print1+'.'+print2+'.'+print3;
  273.     if length(print)<10 then for i:=length(print) to 10 do print:=print+' ';
  274.     if (datum.jahr=stichjahr) then if (datum.monat=stichmonat) then if
  275.        (datum.tag>stichtag_jul) and (datum.tag<stichtag_greg) then 
  276.       datum.system:=3;
  277.     i:=wochentag(datum);
  278.     if datum.system<3 then begin
  279.       case i of
  280.         0 : print:='Sa,'+print;
  281.         1 : print:='So,'+print;
  282.         2 : print:='Mo,'+print;
  283.         3 : print:='Di,'+print;
  284.         4 : print:='Mi,'+print;
  285.         5 : print:='Do,'+print;
  286.         6 : print:='Fr,'+print;
  287.       end;
  288.     end
  289.     else print:='--,'+'--.--.----';
  290.      printat(x,y,print);
  291.   end;
  292.   
  293. procedure ermittle_werte;
  294.   var i      : byte;
  295.       tag    : byte;
  296.       dummy  : real;
  297.       dummy2 : dat;
  298.   
  299.   procedure sonderfall;
  300.     var z,m : integer;
  301.     begin
  302.       if akt_datum.jahr=stichjahr then if i=stichmonat then if 
  303.       tag=stichtag_greg-1 then begin
  304.         for z:=stichtag_jul+1 to stichtag_greg-1 do
  305.           for m:=1 to 3 do
  306.             wert[m,i,z]:=200;
  307.         akt_datum.system:=2;
  308.         dummy:=dummy-10;
  309.         dummy2.system:=2;
  310.       end;
  311.       if akt_datum.schalt=false then if i=2 then if tag=29 then begin
  312.         wert[1,2,29]:=200;
  313.         wert[2,2,29]:=200;
  314.         wert[3,2,29]:=200;
  315.         dummy:=dummy-1;
  316.       end;
  317.       if dummy<0 then begin
  318.         for z:=1 to 3 do
  319.           wert[z,i,tag]:=200;
  320.       end;
  321.     end;
  322.   
  323.   begin
  324.     dummy:=0;
  325.     if akt_datum.jahr=stichjahr then akt_datum.system:=1;
  326.     dummy2:=akt_datum;
  327.     dummy2.monat:=1;
  328.     dummy2.tag:=1;
  329.     zeitdifferenz(dummy,geb_datum,dummy2);
  330.     if (geb_datum.system=2) and (akt_datum.jahr=stichjahr) then 
  331.       dummy:=dummy+20;
  332.     for i:=1 to 12 do begin
  333.       print:='** Ermittle '+monatsn[i]+'. Bitte Warten. **     ';
  334.       printat(23,16,print);
  335.       for tag:=1 to monatsl[i] do begin
  336.         wert[1,i,tag]:=round(sin(koerper*dummy)*50+null);
  337.         wert[2,i,tag]:=round(sin(seele*dummy)*50+null);
  338.         wert[3,i,tag]:=round(sin(geist*dummy)*50+null);
  339.         if (akt_datum.jahr=stichjahr) or (akt_datum.schalt=false) or (dummy<0)
  340.         then sonderfall;
  341.         dummy:=dummy+1;
  342.       end;
  343.     end;
  344.   end;
  345.   
  346. procedure box (x1,y1,x2,y2 : integer);
  347.   
  348.   procedure zeichne;
  349.   begin
  350.     line(x1,y1,x2,y1);
  351.     line(x2,y1,x2,y2);
  352.     line(x2,y2,x1,y2);
  353.     line(x1,y2,x1,y1);
  354.   end;
  355.   
  356.   procedure zeichne2;
  357.   begin
  358.     line(x2,y1,x2,y2);
  359.     line(x2,y2,x1,y2);
  360.   end;
  361.   
  362.   begin
  363.     x1:=x1+3;y1:=y1-1;x2:=x2+3;y2:=y2-1;
  364.     zeichne2;
  365.     x1:=x1-3;y1:=y1+1;x2:=x2-3;y2:=y2+1;
  366.     zeichne;
  367.   end;
  368.       
  369. procedure bildschirmaufbau;
  370.   begin
  371.     hireson;
  372.     clrhires;
  373.     box(2,199,635,110);
  374.     box(2,107,635,3);
  375.     box(300,185,610,118);
  376.     box(17,146,160,118);
  377.     box(180,146,250,118);
  378.     line(190,140,240,140);
  379.     line(190,132,200,132);line(210,132,220,132);line(230,132,240,132);
  380.     plot(190,124);plot(200,124);plot(210,124);plot(220,124);plot(230,124);
  381.     plot(240,124);
  382.     box(17,185,147,165);
  383.     box(160,185,290,165);
  384.     printat(39,3,'Biorhythmus '+imp_version+':(c) Matthias Berger');
  385.     printat(39,4,'------------------------------------');
  386.     printat(39,6,'Wertebereich : -50 -> 50');
  387.     printat(39,8,'A/D : Tag   Y/C : Monat        (-/+)'); 
  388.     printat(39,9,' J  : Datum  L  : Drucke');
  389.     printat(39,10,' H  : Copy   S  : Deuten   E  : Ende');
  390.     printat(4,8,'Körper :');
  391.     printat(4,9,'Seele  :');
  392.     printat(4,10,'Geist  :');
  393.     printat(4,3,'Geb. Datum:');
  394.     printat(22,3,'Akt. Datum:');
  395.     line(42,null,598,null);
  396.     line(42,null-1,598,null-1);
  397.     line(40,null+50,40,null-50);
  398.     line(41,null+50,41,null-50);
  399.     for i:=1 to 5 do begin
  400.       line(35,null+i*10,45,null+i*10);
  401.       line(35,null-i*10,45,null-i*10);
  402.     end; 
  403.     for i:=1 to 31 do begin
  404.       line(40+i*18,null+2,40+i*18,null-2);
  405.       line(41+i*18,null+2,41+i*18,null-2);
  406.     end;
  407.     writesmall(1,round((200-null-10)/8),'+10');    { Aufgrund der groben  }
  408.     writesmall(1,round((200-null+10)/8)+1,'-10');  { Rundung ist ein Be-  }
  409.     writesmall(1,round((200-null-20)/8),'+20');    { schriftung per FOR-  }
  410.     writesmall(1,round((200-null+20)/8),'-20');    { DO-Schleife nicht zu }
  411.     writesmall(1,round((200-null-30)/8)+1,'+30');  { empfehlen !          }
  412.     writesmall(1,round((200-null+30)/8),'-30');  
  413.     writesmall(1,round((200-null-40)/8)+1,'+40');  { Die x/y-Koordinaten  }
  414.     writesmall(1,round((200-null+40)/8),'-40');    { müssen die gleichen  }
  415.     writesmall(1,round((200-null-50)/8)+1,'+50');  { Dimensionen haben    }
  416.     writesmall(1,round((200-null+50)/8),'-50');    { wie die x/y-Koordi-  }
  417.     writesmall(15,round((200-null)/8)+1,'5');      { naten der 'printat'- }
  418.     writesmall(26,round((200-null)/8)+1,'10');     { Routine !            }
  419.     writesmall(37,round((200-null)/8)+1,'15');
  420.     writesmall(48,round((200-null)/8)+1,'20');
  421.     writesmall(59,round((200-null)/8)+1,'25');
  422.     writesmall(71,round((200-null)/8)+1,'30');
  423.   end;
  424.   
  425. function schaltjahr (jahr : integer) : boolean;
  426.   var richtig : boolean;
  427.   begin
  428.     richtig:=false;
  429.     if jahr<stichjahr then begin
  430.       if jahr mod 4 = 0 then richtig:=true;
  431.     end
  432.     else begin
  433.       if (jahr mod 4 = 0) then richtig:=true;
  434.       if (jahr mod 100=0) and (jahr mod 400<>0) then richtig:=false;
  435.     end;
  436.     schaltjahr:=richtig;
  437.   end;
  438.  
  439. procedure datumseingabe;
  440.   
  441.   procedure datumseing2 (var datum : dat);
  442.     var richtig:boolean;
  443.     begin
  444.     repeat
  445.       repeat
  446.         write(' Jahr (>0000): ');readln(datum.jahr);
  447.       until datum.Jahr>0;
  448.       datum.schalt:=schaltjahr(datum.jahr);
  449.       repeat
  450.         write(' Monat: ');readln(datum.monat);
  451.       until (datum.monat<=12);
  452.       repeat
  453.         write(' Tag (<=',monatsl[datum.monat],'): ');readln(datum.tag);
  454.       until (datum.tag<=monatsl[datum.monat]);
  455.       richtig:=true;
  456.       if (datum.monat=2) and (not datum.schalt) and
  457.          (datum.tag=29) then datum.tag:=datum.tag-1;
  458.       if julianisch(datum)<=testdiff then datum.system:=1
  459.       else datum.system:=2;
  460.       if (datum.jahr=stichjahr) and (datum.monat=stichmonat) and
  461.          (datum.tag>stichtag_jul) and (datum.tag<stichtag_greg) then begin
  462.         writeln;
  463.         writeln(' !   Dieses Datum hat nie exisiert, es wurde bei der   ! ');
  464.         write(' !      Kalenderumstellung anno ',stichjahr,' ausgelassen. ');
  465.         writeln('     !');
  466.         writeln(' !               Bitte neuen Tag eingeben              ! ');
  467.         writeln;
  468.         richtig:=false;
  469.       end;
  470.     until richtig;
  471.    end;
  472.  
  473.  begin
  474.    hireson;
  475.    clrhires;
  476.    hiresoff;
  477.    clrscr;
  478.    writeln('Biorhythmusberechnung V ',imp_version,'  - DATUMSEINGABE');
  479.    writeln('---------------------------------------------');
  480.    writeln;writeln;
  481.    writeln('Bitte geben Sie zuerst das Geburtsdatum der Person ein,');
  482.    writeln('deren Biorhythmus ermittelt werden soll.:');
  483.    writeln;
  484.    datumseing2(geb_datum);
  485.    writeln;
  486.    writeln('Geben Sie nun das Datum ein, daß Sie erläutert haben wollen.:');
  487.    writeln;
  488.    datumseing2(akt_datum);
  489.    bildschirmaufbau;
  490.    ermittle_werte;
  491.    drucke(4,4,geb_datum);
  492.    printat(23,16,'                                          ');
  493.  end;
  494.  
  495. procedure deute(akt_datum: dat;single : boolean);
  496.   var i,u : integer;
  497.       x   : real;
  498.   begin
  499.     for i:=1 to 40 do write(lst,'.');writeln(lst,druckstr[1],druckstr[3]);
  500.     write(lst,'Sie haben am ',druckstr[5]);
  501.     case wochentag(akt_datum) of
  502.       0 : write(lst,'Sa');
  503.       1 : write(lst,'So');
  504.       2 : write(lst,'Mo');
  505.       3 : write(lst,'Di');
  506.       4 : write(lst,'Mi');
  507.       5 : write(lst,'Do');
  508.       6 : write(lst,'Fr');
  509.     end;
  510.     writeln(lst,druckstr[6],
  511.                 ', den ',akt_datum.tag,'.',akt_datum.monat,'.',akt_datum.jahr);
  512.     for i:=1 to 3 do
  513.     begin
  514.       if wert[i,akt_datum.monat,akt_datum.tag]<200 then write(lst,' eine ');
  515.       u:=-5;
  516.       repeat
  517.         if (int((wert[i,akt_datum.monat,akt_datum.tag]-null)/10) = u) then
  518.         case u of
  519.           -5 : write(lst,' besch[eidene] ');
  520.           -4 : write(lst,' schlechte ');
  521.           -3 : write(lst,' ungute ');
  522.           -2 : write(lst,' mässige ');
  523.           -1 : write(lst,' abgeschlaffte ');
  524.           0  : write(lst,' gefährliche ');  
  525.            1 : write(lst,' ziemlich günstige ');
  526.            2 : write(lst,' annehmbare ');
  527.            3 : write(lst,' gute ');
  528.            4 : write(lst,' optimale ');
  529.            5 : write(lst,' ausgezeichnete ');
  530.         end;
  531.         u:=u+1;
  532.       until (int((wert[i,akt_datum.monat,akt_datum.tag]-null)/ 10) = (u-1))
  533.             or (wert[i,akt_datum.monat,akt_datum.tag]=200);
  534.       if (wert[i,akt_datum.monat,akt_datum.tag]=200) then begin
  535.         if i=1 then 
  536.           writeln(lst,' gar nicht gelebt.');
  537.       end 
  538.       else begin
  539.         case i of 
  540.           1  : writeln(lst,' Kondition ');
  541.           2  : writeln(lst,' Seelenlage ');
  542.           3  : writeln(lst,' Geisteskraft. ');
  543.         end;
  544.       end;
  545.     end;
  546.     if int((wert[1,akt_datum.monat,akt_datum.tag]-null)/10) =
  547.        int((wert[2,akt_datum.monat,akt_datum.tag]-null)/10) then
  548.        if wert[2,akt_datum.monat,akt_datum.tag]-null>0 then 
  549.           write(lst,druckstr[1],'Guter Tag für alle Angelegenheiten ! ')
  550.        else if wert[2,akt_datum.monat,akt_datum.tag]-null<0 then
  551.           write(lst,druckstr[1],'Schlechter Tag für alle Angelegenheiten ! ');
  552.        
  553.     if ((wert[1,akt_datum.monat,akt_datum.tag]-null) div 10) = 0 then
  554.       if ((wert[2,akt_datum.monat,akt_datum.tag]-null) div 10) = 0 then
  555.          if ((wert[3,akt_datum.monat,akt_datum.tag]-null) div 10) = 0 then 
  556.            if (akt_datum.jahr)<>(geb_datum.jahr) then begin
  557.              writeln(lst,druckstr[1]
  558.                         ,' GEFAHR ! DREI NULLDURCHGÄNGE ! GEFAHR !');
  559.              writeln(lst,' ACHTUNG VOR UNFÄLLEN/KRANKHEITEN/TOD  ! ');
  560.            end;
  561.     if single then begin 
  562.       write(lst,druckstr[1]);
  563.       if wert[1,akt_datum.monat,akt_datum.tag]<200 then begin
  564.         write(lst,'Das ist ihr ');
  565.         zeitdifferenz(x,geb_datum,akt_datum);
  566.         i:=round(x)+1;
  567.         writeln(lst,i,'. Lebenstag.');
  568.       end;
  569.       write(lst,druckstr[1],'Gültig für Geb.-Datum : ');
  570.       case wochentag(geb_datum) of
  571.         0 : write(lst,'Sa');
  572.         1 : write(lst,'So');
  573.         2 : write(lst,'Mo');
  574.         3 : write(lst,'Di');
  575.         4 : write(lst,'Mi');
  576.         5 : write(lst,'Do');
  577.         6 : write(lst,'Fr');
  578.       end;
  579.       writeln(lst,',',geb_datum.tag,'.',geb_datum.monat,'.',
  580.               geb_datum.jahr,'.',druckstr[1],' -mkb 88');
  581.     end;
  582.     write(lst,druckstr[4]);for i:=1 to 40 do write(lst,'.');writeln(lst);
  583.   end;
  584.  
  585. procedure druckerausgabe;
  586.   var y,i,u,bte : integer;
  587.       x         : real;
  588.       m         : char;
  589.       dummy     : dat;
  590.    
  591.   procedure plusminus(x : integer);
  592.     var i : integer;
  593.         c : char;
  594.     begin
  595.       x:=x-null;
  596.       if x<=50 then begin 
  597.         if x<10 then if x>-10 then 
  598.           print:='  '+druckstr[3]+' CAUTIONDAY '+druckstr[4];
  599.         if x>=10 then begin
  600.           print:='        ';
  601.           for  i:=1 to (x div 10) do
  602.             print:=print+'+';
  603.         end
  604.         else if x<-10 then begin
  605.           print:='';
  606.           for i:=1 to ((x*-1) div 10) do
  607.             print:=print+'-';  
  608.         end;
  609.       end
  610.       else print:='               (nicht gelebt)';
  611.     end;
  612.   
  613.   begin
  614.     curs_on;
  615.     printat(39,5,'Druckerausgabe mit Deutung (J/N) :');
  616.     read(kbd,m);m:=upcase(m);
  617.     printat(39,5,'                                   ');
  618.     curs_off;
  619.     dummy:=akt_datum;
  620.     dummy.tag:=1;
  621.     writeln(lst,druckstr[2]);writeln(lst);
  622.     writeln(lst,'Biorhythmuswerte');
  623.     writeln(lst,'----------------');
  624.     writeln(lst);writeln(lst);
  625.     writeln(lst,'Für:');
  626.     write(lst,'Geb. am : ');
  627.     case wochentag(geb_datum) of
  628.         0 : write(lst,'Sa');
  629.         1 : write(lst,'So');
  630.         2 : write(lst,'Mo');
  631.         3 : write(lst,'Di');
  632.         4 : write(lst,'Mi');
  633.         5 : write(lst,'Do');
  634.         6 : write(lst,'Fr');
  635.       end;
  636.     write(lst,', ',geb_datum.tag,'. ',monatsn[geb_datum.monat]);
  637.     writeln(lst,' ',geb_datum.jahr);
  638.     write(lst,'Geltungsmonat: ',monatsn[akt_datum.monat]);
  639.     writeln(lst,' ',akt_datum.jahr);
  640.     write(lst,'Der Monat enthält den ');
  641.     zeitdifferenz(x,geb_datum,dummy); i:=round(x)+1;
  642.     write(lst,i,'. - ');
  643.     dummy.tag:=monatsl[akt_datum.monat];
  644.     if (akt_datum.monat=2) and (not akt_datum.schalt) then
  645.       dummy.tag:=28;
  646.     zeitdifferenz(x,geb_datum,dummy); i:=round(x)+1;
  647.     writeln(lst,i,'. Lebenstag. ');
  648.     writeln(lst);writeln(lst);
  649.     u:=monatsl[akt_datum.monat];
  650.     if (u=28) and (schaltjahr(akt_datum.jahr)) then u:=29;
  651.     for i:=1 to u do begin
  652.       if m='N' then begin
  653.         writeln(lst);writeln(lst,druckstr[3],
  654.                              druckstr[5],' ',i,' ',druckstr[6],druckstr[4]);
  655.         for w:= 1 to 3 do begin
  656.           case w of 
  657.             1 : write(lst,'Körper:  ');
  658.             2 : write(lst,'Seele :  ');
  659.             3 : write(lst,'Geist :  ');
  660.           end;
  661.           write(lst,wert[w,akt_datum.monat,i]-null);
  662.           plusminus(wert[w,akt_datum.monat,i]);
  663.           writeln(lst,'    ',print);
  664.         end;
  665.         if wert[1,akt_datum.monat,akt_datum.tag] div 10 =
  666.            wert[2,akt_datum.monat,akt_datum.tag] div 10 then
  667.            if wert[2,akt_datum.monat,akt_datum.tag]-null>0 then 
  668.              write(lst,druckstr[1],'Guter Tag für alle Angelegenheiten ! ')
  669.            else if wert[2,akt_datum.monat,akt_datum.tag]-null<0 then
  670.              write(lst,druckstr[1],
  671.                    'Schlechter Tag für alle Angelegenheiten ! ');
  672.       end else begin
  673.         dummy.tag:=i;
  674.         deute(dummy,false);
  675.       end;
  676.     end;
  677.     writeln(lst);writeln(lst);writeln(lst,'Biorhythmus erstellt auf einem ');
  678.     write(lst,'atari st/[c 128]/[s-pc/d];');
  679.     writeln(lst,'(C) 1987 Matthias Berger/(c) 88 mkb [rewritten]');
  680.     writeln(lst);writeln(lst,druckstr[2]);
  681.   end;
  682.   
  683.  
  684. procedure hauptprogramm;
  685.   var i     : integer;
  686.       wahl  : char;
  687.       monat : boolean;
  688.       jahr  : boolean;
  689.       
  690.   procedure zeichne(datum : dat);     { Diese Procedure zeichnet alleine }
  691.     var i : integer;                  { die Rhythmenkurven anhand der    }
  692.         u : byte;                     { Werte in drei Linienarten (Sys-  }
  693.         z : boolean;                  { temunabhängig !)                 }
  694.         l : dat;
  695.     begin
  696.       z:=false;
  697.       for i:=1 to monatsl[datum.monat]-1 do begin
  698.         z:=not z;
  699.         for u:=1 to 3 do begin
  700.           if ((u=1) or ((u=2) and (z=true))) and (wert[u,datum.monat,i]<200)
  701.           and (wert[u,datum.monat,i+1]<200) then
  702.             line(49+(18*(i-1)),wert[u,datum.monat,i],
  703.                  49+(18*i)-1,wert[u,datum.monat,i+1]);
  704.           if (u=3) and (wert[u,datum.monat,i]<200) and 
  705.              (wert[u,datum.monat,i+1]<200) then begin
  706.             line(49+(18*(i-1)),wert[u,datum.monat,i],49+(18*(i-1))-1,
  707.                  wert[u,datum.monat,i]-1);
  708.             if i=monatsl[datum.monat]-1 then 
  709.               line(49+(18*i),wert[u,datum.monat,i+1],49+(18*(i))-1,
  710.                    wert[u,datum.monat,i+1]);
  711.           end;
  712.         end;
  713.       end;
  714.       l:=akt_datum;l.tag:=1;
  715.       if ((l.jahr=stichjahr) and (l.monat<>stichmonat))
  716.          or (l.jahr<>stichjahr) then
  717.       begin
  718.         repeat
  719.           if wochentag(l)=1 then begin
  720.             for i:=0 to 4 do
  721.               line(47+i+(18*(l.tag-1)),null+4,47+i+(18*(l.tag-1)),null-4);
  722.             l.tag:=l.tag+7;
  723.           end
  724.           else l.tag:=l.tag+1;
  725.         until l.tag>monatsl[l.monat];
  726.       end;
  727.     end;
  728.     
  729.   procedure linie (datum : dat);
  730.     begin
  731.       line(49+((datum.tag-1)*18),null+50,49+((datum.tag-1)*18),null-50);
  732.     end;
  733.   
  734. begin
  735.   testdat.jahr:=stichjahr;testdat.tag:=stichtag_jul;testdat.monat:=stichmonat;
  736.   testdat.system:=1;testdat.schalt:=false;
  737.   testdiff:=julianisch(testdat); 
  738.   beenden:=false;
  739.   repeat
  740.     jahr:=false;
  741.     datumseingabe;
  742.     repeat
  743.       monat:=false;
  744.       zeichne(akt_datum);
  745.       repeat
  746.         drucke(22,4,akt_datum);
  747.         linie(akt_datum);
  748.         for i:=1 to 3 do begin
  749.           str(wert[i,akt_datum.monat,akt_datum.tag]-null,print);
  750.           if length(print)<3 then for u:=1 to 3-length(print) do
  751.             print:=print+' '; 
  752.           if wert[i,akt_datum.monat,akt_datum.tag]=200 then print:='---';
  753.           printat(16,7+i,print);
  754.         end;
  755.         repeat
  756.           read(kbd,wahl);
  757.         until wahl in ['a','A','d','D','y','Y','c','C','j','J','l','L',
  758.                        'e','E','h','H','s','S'];
  759.         linie(akt_datum);
  760.         case wahl of
  761.           'a','A' :  begin
  762.                        akt_datum.tag:=akt_datum.tag-1;
  763.                        if akt_datum.tag<1 then begin
  764.                          monat:=true;
  765.                          zeichne(akt_datum);
  766.                          akt_datum.tag:=monatsl[akt_datum.monat-1];
  767.                          if (akt_datum.monat=3) and (not akt_datum.schalt)
  768.                            then akt_datum.tag:=28;
  769.                          if akt_datum.monat-1<1 then jahr:=true;
  770.                          akt_datum.monat:=akt_datum.monat-1;
  771.                        end;
  772.                      end;
  773.           'd','D' :  begin
  774.                        akt_datum.tag:=akt_datum.tag+1;
  775.                        if (akt_datum.tag>monatsl[akt_datum.monat])
  776.                           or ((akt_datum.monat=2) and (not akt_datum.schalt)
  777.                           and (akt_datum.tag=29)) then begin
  778.                          monat:=true;
  779.                          zeichne(akt_datum);
  780.                          akt_datum.tag:=1;
  781.                          if akt_datum.monat+1>12 then jahr:=true;
  782.                          akt_datum.monat:=akt_datum.monat+1;
  783.                        end;
  784.                      end;
  785.           'e','E' :  begin
  786.                        hiresoff;
  787.                        beenden:=true;
  788.                      end;
  789.           'y','Y' :  begin
  790.                        monat:=true;
  791.                        zeichne(akt_datum);
  792.                        akt_datum.monat:=akt_datum.monat-1;
  793.                        if akt_datum.monat<1 then jahr:=true;
  794.                      end;
  795.           'c','C' :  begin
  796.                        monat:=true;
  797.                        zeichne(akt_datum);
  798.                        akt_datum.monat:=akt_datum.monat+1;
  799.                        if akt_datum.monat>12 then jahr:=true;
  800.                      end;
  801.           'j','J' :  begin
  802.                        jahr:=true;
  803.                        monat:=true;
  804.                      end;
  805.           'l','L' : druckerausgabe;
  806.           'h','H' : begin
  807.                       linie(akt_datum);
  808.                       hardcopy;
  809.                       linie(akt_datum);
  810.                     end;
  811.           's','S' : deute(akt_datum,true);
  812.         end; 
  813.         if julianisch(akt_datum)<=testdiff then akt_datum.system:=1 else
  814.                                                 akt_datum.system:=2;
  815.       until (monat) or (beenden);
  816.     until (jahr) or (beenden);
  817.     hiresoff
  818.   until (geb_datum.jahr<0) or (beenden);
  819. end;
  820.  
  821. begin
  822.   initarrays;
  823.   druckeranpassung;
  824.   hauptprogramm; 
  825.   clrscr;writeln('(c) mkb rewritten dec. 88 on atari from c128');
  826. end.
  827.  
  828.  
  829. { Es wurden im systemunabhängigen Teil nur übliche impl. Proceduren/Functionen}
  830. { verwendet. Läßt sich eine, nicht elementar wichtige, systemabhängige,       }
  831. { Procedure/Function keine Implementation finden, so läßt man den Anweisungs- }
  832. { teil dieser Procedure/Function leer.                                        }
  833.  
  834. { Das Programm läuft   auf System            impl. Version   für Drucker      }
  835.  
  836. { --------------------------------------------------------------------------- }
  837. {                                                                             }
  838. {                      - CPM+/C128d             3.z[80]G     sl80ai/ipd560    }
  839. {                      - MS-dos/Siemens PC-d    3.i[86]G     ibm-comp.        }
  840. {                      - ATARI ST               4.m[86]G     sl80ai[ibm/fx80] }
  841. {                                                                             }
  842.  
  843. { Entwicklungssystem war ein C128d mit 80-Zeichen-Monochrom-Monitor und       }
  844. { SL80ai-Drucker unter CP/M+. Entwicklungssprache war TURBO-PASCAL.           }
  845. { Die Sprache wurde anderen Versionen angepasst, die Grafik/Text-Vorgaben     }
  846. { sind voll in den computerunabhängigen Teil übernommen worden, da sie einen  }
  847. { Minimal-Standart darstellen. Bitte die Umrechnungsangaben im computersprez- }
  848. { ifischen Teil beachten.                                                     }